home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / packages / edit-faces.el < prev    next >
Encoding:
Text File  |  1995-08-15  |  9.7 KB  |  306 lines
  1. ;;; edit-faces.el -- interactive face editing mode
  2.  
  3. ;; Copyright (C) 1994, 1995 Tinker Systems and INS Engineering Corp.
  4. ;; 
  5. ;; This file is part of XEmacs.
  6. ;; 
  7. ;; XEmacs is free software; you can redistribute it and/or modify
  8. ;; it under the terms of the GNU General Public License as published by
  9. ;; the Free Software Foundation; either version 2 of the License, or
  10. ;; (at your option) any later version.
  11. ;; 
  12. ;; XEmacs is distributed in the hope that it will be useful,
  13. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15. ;; GNU General Public License for more details.
  16. ;; 
  17. ;; You should have received a copy of the GNU General Public License
  18. ;; along with XEmacs; if not, write to the Free Software
  19. ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21. (defvar edit-faces-map
  22.   (let ((map (make-sparse-keymap)))
  23.     (suppress-keymap map)
  24.     (define-key map "<" 'ef-smaller)
  25.     (define-key map ">" 'ef-larger)
  26.     (define-key map "c" 'ef-copy-other-face)
  27.     (define-key map "C" 'ef-copy-this-face)
  28.     (define-key map "s" 'ef-smaller)
  29.     (define-key map "l" 'ef-larger)
  30.     (define-key map "b" 'ef-bold)
  31.     (define-key map "i" 'ef-italic)
  32.     (define-key map "e" 'ef-font)
  33.     (define-key map "f" 'ef-font)
  34.     (define-key map "u" 'ef-underline)
  35.     (define-key map "t" 'ef-truefont)
  36.     (define-key map "F" 'ef-foreground)
  37.     (define-key map "B" 'ef-background)
  38.     (define-key map "d" 'ef-delete)
  39.     (define-key map "n" 'ef-next)
  40.     (define-key map "p" 'ef-prev)
  41.     (define-key map " " 'ef-next)
  42.     (define-key map "\C-?" 'ef-prev)
  43.     (define-key map "g" 'edit-faces)    ; refresh display
  44.     (define-key map "q" 'ef-quit)
  45.     (define-key map "\C-c\C-c" 'bury-buffer)
  46.     map    
  47.     ))
  48.  
  49. (defvar edit-faces-menu
  50.   '("Edit-Faces"
  51.     ["Copy other face..." ef-copy-other-face t]
  52.     ["Copy this face..." ef-copy-this-face t]
  53.     ["Make smaller"    ef-smaller    t]
  54.     ["Make larger"    ef-larger    t]
  55.     ["Toggle bold"    ef-bold        t]
  56.     ["Toggle italic"    ef-italic    t]
  57.     ["Toggle underline"    ef-underline    t]
  58.     ["Query true font"    ef-truefont    t]
  59.     ["Set font"        ef-font        t]
  60.     ["Set foreground"    ef-foreground    t]
  61.     ["Set background"    ef-background    t]
  62.     ["Quit"        ef-quit        t]
  63.     ))
  64.  
  65. (or (find-face 'underline)
  66.     (progn (make-face 'underline)
  67.        (set-face-underline-p 'underline t)))
  68.  
  69. ;;;###autoload
  70. (defun edit-faces ()
  71.   "Alter face characteristics by editing a list of defined faces.
  72. Pops up a buffer containing a list of defined faces.
  73.  
  74. Editing commands:
  75.  
  76. \\{edit-faces-map}"
  77.   (interactive)
  78.   (pop-to-buffer (get-buffer-create "*Edit Faces*"))
  79.   (setq buffer-read-only nil
  80.     major-mode 'edit-faces
  81.     mode-name  "Edit-Faces"
  82.     mode-popup-menu edit-faces-menu)
  83.   (if current-menubar
  84.       (progn
  85.     (set (make-local-variable 'current-menubar)
  86.          (copy-sequence current-menubar))
  87.     (add-submenu nil edit-faces-menu)))
  88.   (erase-buffer)
  89.  
  90.   ;; face-list returns faces in a random order so we sort
  91.   ;; alphabetically by the name in order to insert some logic into
  92.   ;; the ordering.
  93.   (let ((flist (sort (face-list)
  94.              (function
  95.               (lambda (x y)
  96.             (string-lessp (symbol-name x) (symbol-name y))))))
  97.     face)
  98.     (ef-update-face-description t)    ; insert header line
  99.     (while (setq face (car flist))
  100.       (ef-update-face-description face)
  101.       (setq flist (cdr flist))
  102.       ))
  103.   (goto-char (point-min)) 
  104.   (setq buffer-read-only t)
  105.   (use-local-map edit-faces-map))
  106.  
  107. (defun ef-update-face-description (face &optional replace)
  108.   "Given a face, inserts a description of that face into the current buffer.
  109. Inserts a descriptive header if passed `t'."
  110.   (let ((fmt "%-25s %-15s %-15s\n    %s\n")
  111.     (buffer-read-only nil)
  112.     fg bg font ex)
  113.     (if (eq face t)
  114.     (insert-face (format fmt "Face" "Foreground" "Background" "Font Spec")
  115.             'underline)
  116.       (or replace (setq replace face))
  117.       (goto-char (point-min)) 
  118.       (if (re-search-forward (concat "^" (symbol-name replace) " ") nil 0)
  119.       (progn
  120.         (beginning-of-line)
  121.         (delete-region (point) (progn (forward-line 2) (point)))
  122.         ))
  123.       (setq fg (face-foreground-instance face)
  124.         bg (face-background-instance face)
  125.         font (face-font-instance face)
  126.         ex (insert-face (format fmt
  127.                    (symbol-name face)
  128.                    (and fg (color-instance-name fg))
  129.                    (and bg (color-instance-name bg))
  130.                    (and font (font-instance-name font)))
  131.                face))
  132.       (set-extent-property ex 'eface t)
  133.       (set-extent-property ex 'start-open t)
  134.       (and replace (forward-line -1))
  135.       ))
  136.   )
  137.  
  138. (defun ef-face-arg ()
  139.    (and current-mouse-event
  140.     (mouse-set-point current-mouse-event))
  141.    (let ((ex (extent-at (1+ (point)) nil 'eface))) ; 1+ is a hack to deal
  142.                            ; with start-open
  143.      (or ex (error "There is no face to edit on this line."))
  144.      (extent-face ex)))
  145.  
  146. (defun ef-delete (arg)
  147.   "Delete the face on the current line from the *Edit Faces* buffer.
  148. The face is not altered.  The buffer can be regenerated again with
  149. M-x edit-faces."
  150.   (interactive "p") 
  151.   (and current-mouse-event
  152.        (mouse-set-point current-mouse-event))
  153.   (let ( ;; is this worth the bother? (fwd (> arg 0))
  154.     (count (abs arg))
  155.     (buffer-read-only nil)
  156.     ex)
  157.     (while (not (zerop (prog1 count (setq count (1- count)))))
  158.       ;; 1+ is a hack to deal with start-open
  159.       (setq ex (extent-at (1+ (point)) nil 'eface)) 
  160.       (or ex (error "There is no face to delete on this line."))
  161.       (delete-region (extent-start-position ex) (extent-end-position ex))
  162.       (delete-blank-lines))))
  163.   
  164. (defun ef-next (arg)
  165.   "Move forward ARG entries in the face table"
  166.   (interactive "p") 
  167.   (let ((fwd (> arg 0))
  168.     (count (abs arg))
  169.     ex)
  170.     (while (not (zerop (prog1 count (setq count (1- count)))))
  171.       ;; #### - 1+ is a hack to deal with start-open extents.  If they're not
  172.       ;; start-open, then inserting text at the start of an extent will
  173.       ;; cause the extent to grow, which is not desirable. 
  174.       (setq ex (extent-at (1+ (point)) nil 'eface)) 
  175.       (and ex
  176.        (if fwd
  177.            (progn (goto-char (extent-end-position ex))
  178.               (beginning-of-line 2))
  179.          (goto-char (extent-start-position ex))
  180.          (beginning-of-line -1)))    ; ain't bug-compatibility great?
  181.       )))
  182.  
  183. (defun ef-prev (arg)
  184.   "Move forward ARG entries in the face table"
  185.   (interactive "p") 
  186.   (ef-next (- arg)))
  187.  
  188. (defun ef-smaller (face)
  189.   (interactive (list (ef-face-arg)))
  190.   (make-face-smaller face)
  191.   (ef-update-face-description face))
  192.  
  193. (defun ef-larger (face)
  194.   (interactive (list (ef-face-arg)))
  195.   (make-face-larger face)
  196.   (ef-update-face-description face))
  197.  
  198. (defun ef-face-font-indirect (face)
  199.   (let ((font (face-font-instance face)))
  200.     (or font (face-font-instance 'default))))
  201.  
  202. (defun ef-face-bold-p (face)
  203.   (let ((font (ef-face-font-indirect face)))
  204.     (not (not (string-match "-bold-" (font-instance-name font))))))
  205.  
  206. (defun ef-face-italic-p (face)
  207.   (let ((font (ef-face-font-indirect face)))
  208.     (not (not (string-match "-[io]-" (font-instance-name font))))))
  209.  
  210. (defun ef-bold (face)
  211.   (interactive (list (ef-face-arg)))
  212.   (if (ef-face-bold-p face)
  213.       (make-face-unbold face)
  214.     (make-face-bold face))
  215.   (ef-update-face-description face))
  216.  
  217. (defun ef-italic (face)
  218.   (interactive (list (ef-face-arg)))
  219.   (if (ef-face-italic-p face)
  220.       (make-face-unitalic face)
  221.     (make-face-italic face))
  222.   (ef-update-face-description face))
  223.  
  224. (defun ef-underline (face)
  225.   (interactive (list (ef-face-arg)))
  226.   (set-face-underline-p face (not (face-underline-p face)))
  227.   (ef-update-face-description face))
  228.  
  229. (defun ef-truefont (face)
  230.   (interactive (list (ef-face-arg)))
  231.   (let ((font (face-font-instance face))
  232.     (name (symbol-name face)))
  233.     (if font
  234.     (message "True font for `%s': %s" name (font-instance-truename font))
  235.       (message "The face `%s' does not have its own font." name))))
  236.  
  237. (defun ef-foreground (face color)
  238.   (interactive
  239.    (let* ((f (ef-face-arg))
  240.       (name (symbol-name f))
  241.       (c (read-color (format "Foreground color for `%s': " name))))
  242.      (list f c)))
  243.   (set-face-foreground face color)
  244.   (ef-update-face-description face))
  245.  
  246. (defun ef-background (face color)
  247.   (interactive
  248.    (let* ((f (ef-face-arg))
  249.       (name (symbol-name f))
  250.       (c (read-color (format "Background color for `%s': " name))))
  251.      (list f c)))
  252.   (set-face-background face color)
  253.   (ef-update-face-description face))
  254.  
  255. (defun ef-copy-other-face (src dst)
  256.   (interactive
  257.    (let* ((f (ef-face-arg))
  258.       (name (symbol-name f)))
  259.      (list (read-face (format "Make `%s' a copy of what face?: " name) t) f)))
  260.   (copy-face src dst)
  261.   (ef-update-face-description dst dst))
  262.  
  263. (defun ef-copy-this-face (src dst)
  264.   (interactive
  265.    (let* ((f (ef-face-arg))
  266.       (name (symbol-name f)))
  267.        (list f (read-face (format "Copy `%s' onto what face?: " name)))))
  268.   (copy-face src dst)
  269.   (ef-update-face-description dst dst))
  270.  
  271. (defun ef-font (face font)
  272.   (interactive
  273.    (let* ((f (ef-face-arg))
  274.       (name (symbol-name f))
  275.       (font (face-font-instance f))
  276.       (nf (read-string (format "Font for `%s': " name)
  277.                (and font (font-instance-name font)))))
  278.      (list f nf)))
  279.   (let ((ofont (face-font-instance face))
  280.     others)
  281.     ;; you might think that this could be moved into the loop below, but I
  282.     ;; think that it's important to see the new font before asking if the
  283.     ;; change should be global. 
  284.     (set-face-font face (if (and (string= font "")
  285.                  (not (eq face 'default)))
  286.                 nil font))
  287.     (ef-update-face-description face)
  288.     (setq others (delq nil (mapcar (lambda (f)
  289.                      (and (equal (face-font-instance f) ofont)
  290.                       f))
  291.                    (face-list))))
  292.     (if (and others
  293.          (y-or-n-p "Make the same font change for other faces? "))
  294.     (while others
  295.       (setq face (car others)
  296.         others (cdr others))
  297.       (set-face-font face font)
  298.       (ef-update-face-description face)))
  299.     ))
  300.  
  301. (defun ef-quit ()
  302.   (interactive)
  303.   (or (one-window-p t 0)
  304.       (delete-window))
  305.   (kill-buffer "*Edit Faces*"))
  306.